home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
C/C++ Users Group Library 1996 July
/
C-C++ Users Group Library July 1996.iso
/
vol_100
/
176_01
/
xlread.c
< prev
next >
Wrap
Text File
|
1985-12-08
|
16KB
|
743 lines
/* xlread - xlisp expression input routine */
/* Copyright (c) 1985, by David Michael Betz
All Rights Reserved
Permission is granted for unrestricted non-commercial use */
#include "xlisp.h"
#ifdef MEGAMAX
overlay "io"
#endif
/* external variables */
extern NODE *s_stdout,*true,*s_dot;
extern NODE *s_quote,*s_function,*s_bquote,*s_comma,*s_comat;
extern NODE *s_rtable,*k_wspace,*k_const,*k_nmacro,*k_tmacro;
extern NODE ***xlstack;
extern int xlplevel;
extern char buf[];
/* external routines */
extern FILE *fopen();
extern double atof();
extern ITYPE;
#define WSPACE "\t \f\r\n"
#define CONST1 "!$%&*+-./0123456789:<=>?@[]^_{}~"
#define CONST2 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
/* forward declarations */
FORWARD NODE *callmacro();
FORWARD NODE *phexnumber(),*pquote(),*plist(),*pvector(),*pname();
FORWARD NODE *tentry();
/* xlload - load a file of xlisp expressions */
int xlload(fname,vflag,pflag)
char *fname; int vflag,pflag;
{
NODE ***oldstk,*fptr,*expr;
char fullname[STRMAX+1];
CONTEXT cntxt;
FILE *fp;
int sts;
/* create a new stack frame */
oldstk = xlsave(&fptr,&expr,NULL);
/* create the full file name */
if (needsextension(fname)) {
strcpy(fullname,fname);
strcat(fullname,".lsp");
fname = fullname;
}
/* allocate a file node */
fptr = cvfile(NULL);
/* print the information line */
if (vflag)
{ sprintf(buf,"; loading \"%s\"\n",fname); stdputstr(buf); }
/* open the file */
if ((fp = fopen(fname,"r")) == NULL) {
xlstack = oldstk;
return (FALSE);
}
setfile(fptr,fp);
/* read, evaluate and possibly print each expression in the file */
xlbegin(&cntxt,CF_ERROR,true);
if (setjmp(cntxt.c_jmpbuf))
sts = FALSE;
else {
while (xlread(fptr,&expr,FALSE)) {
expr = xleval(expr);
if (pflag)
stdprint(expr);
}
sts = TRUE;
}
xlend(&cntxt);
/* close the file */
fclose(getfile(fptr));
setfile(fptr,NULL);
/* restore the previous stack frame */
xlstack = oldstk;
/* return status */
return (sts);
}
/* xlread - read an xlisp expression */
int xlread(fptr,pval,rflag)
NODE *fptr,**pval; int rflag;
{
int sts;
/* reset the paren nesting level */
if (!rflag)
xlplevel = 0;
/* read an expression */
while ((sts = readone(fptr,pval)) == FALSE)
;
/* return status */
return (sts == EOF ? FALSE : TRUE);
}
/* readone - attempt to read a single expression */
int readone(fptr,pval)
NODE *fptr,**pval;
{
NODE *val,*type;
int ch;
/* get a character and check for EOF */
if ((ch = xlgetc(fptr)) == EOF)
return (EOF);
/* handle white space */
if ((type = tentry(ch)) == k_wspace)
return (FALSE);
/* handle symbol constituents */
else if (type == k_const) {
*pval = pname(fptr,ch);
return (TRUE);
}
/* handle read macros */
else if (consp(type)) {
if ((val = callmacro(fptr,ch)) && consp(val)) {
*pval = car(val);
return (TRUE);
}
else
return (FALSE);
}
/* handle illegal characters */
else
xlerror("illegal character",cvfixnum((FIXNUM)ch));
}
/* rmhash - read macro for '#' */
NODE *rmhash(args)
NODE *args;
{
NODE ***oldstk,*fptr,*mch,*val;
int ch;
/* create a new stack frame */
oldstk = xlsave(&fptr,&mch,&val,NULL);
/* get the file and macro character */
fptr = xlgetfile(&args);
mch = xlmatch(INT,&args);
xllastarg(args);
/* make the return value */
val = consa(NIL);
/* check the next character */
switch (ch = xlgetc(fptr)) {
case '\'':
rplaca(val,pquote(fptr,s_function));
break;
case '(':
rplaca(val,pvector(fptr));
break;
case 'x':
case 'X':
rplaca(val,phexnumber(fptr));
break;
case '\\':
rplaca(val,cvfixnum((FIXNUM)xlgetc(fptr)));
break;
default:
xlerror("illegal character after #",cvfixnum((FIXNUM)ch));
}
/* restore the previous stack frame */
xlstack = oldstk;
/* return the value */
return (val);
}
/* rmquote - read macro for '\'' */
NODE *rmquote(args)
NODE *args;
{
NODE ***oldstk,*fptr,*mch,*val;
int ch;
/* create a new stack frame */
oldstk = xlsave(&fptr,&mch,&val,NULL);
/* get the file and macro character */
fptr = xlgetfile(&args);
mch = xlmatch(INT,&args);
xllastarg(args);
/* make the return value */
val = consa(NIL);
rplaca(val,pquote(fptr,s_quote));
/* restore the previous stack frame */
xlstack = oldstk;
/* return the value */
return (val);
}
/* rmdquote - read macro for '"' */
NODE *rmdquote(args)
NODE *args;
{
NODE ***oldstk,*fptr,*mch,*val;
int ch,i,d1,d2,d3;
/* create a new stack frame */
oldstk = xlsave(&fptr,&mch,&val,NULL);
/* get the file and macro character */
fptr = xlgetfile(&args);
mch = xlmatch(INT,&args);
xllastarg(args);
/* loop looking for a closing quote */
for (i = 0; i < STRMAX && (ch = checkeof(fptr)) != '"'; i++) {
switch (ch) {
case '\\':
switch (ch = checkeof(fptr)) {
case 'f':
ch = '\f';
break;
case 'n':
ch = '\n';
break;
case 'r':
ch = '\r';
break;
case 't':
ch = '\t';
break;
default:
if (ch >= '0' && ch <= '7') {
d1 = ch - '0';
d2 = checkeof(fptr) - '0';
d3 = checkeof(fptr) - '0';
ch = (d1 << 6) + (d2 << 3) + d3;
}
break;
}
}
buf[i] = ch;
}
buf[i] = 0;
/* initialize the node */
val = consa(NIL);
rplaca(val,cvstring(buf));
/* restore the previous stack frame */
xlstack = oldstk;
/* return the new string */
return (val);
}
/* rmbquote - read macro for '`' */
NODE *rmbquote(args)
NODE *args;
{
NODE ***oldstk,*fptr,*mch,*val;
int ch;
/* create a new stack frame */
oldstk = xlsave(&fptr,&mch,&val,NULL);
/* get the file and macro character */
fptr = xlgetfile(&args);
mch = xlmatch(INT,&args);
xllastarg(args);
/* make the return value */
val = consa(NIL);
rplaca(val,pquote(fptr,s_bquote));
/* restore the previous stack frame */
xlstack = oldstk;
/* return the value */
return (val);
}
/* rmcomma - read macro for ',' */
NODE *rmcomma(args)
NODE *args;
{
NODE ***oldstk,*fptr,*mch,*val,*sym;
int ch;
/* create a new stack frame */
oldstk = xlsave(&fptr,&mch,&val,NULL);
/* get the file and macro character */
fptr = xlgetfile(&args);
mch = xlmatch(INT,&args);
xllastarg(args);
/* check the next character */
if (xlpeek(fptr) == '@') {
sym = s_comat;
xlgetc(fptr);
}
else
sym = s_comma;
/* make the return value */
val = consa(NIL);
rplaca(val,pquote(fptr,sym));
/* restore the previous stack frame */
xlstack = oldstk;
/* return the value */
return (val);
}
/* rmlpar - read macro for '(' */
NODE *rmlpar(args)
NODE *args;
{
NODE ***oldstk,*fptr,*mch,*val;
int ch;
/* create a new stack frame */
oldstk = xlsave(&fptr,&mch,&val,NULL);
/* get the file and macro character */
fptr = xlgetfile(&args);
mch = xlmatch(INT,&args);
xllastarg(args);
/* make the return value */
val = consa(NIL);
rplaca(val,plist(fptr));
/* restore the previous stack frame */
xlstack = oldstk;
/* return the value */
return (val);
}
/* rmrpar - read macro for ')' */
NODE *rmrpar(args)
NODE *args;
{
xlfail("misplaced right paren");
}
/* rmsemi - read macro for ';' */
NODE *rmsemi(args)
NODE *args;
{
NODE ***oldstk,*fptr,*mch;
int ch;
/* create a new stack frame */
oldstk = xlsave(&fptr,&mch,NULL);
/* get the file and macro character */
fptr = xlgetfile(&args);
mch = xlmatch(INT,&args);
xllastarg(args);
/* skip to en